home *** CD-ROM | disk | FTP | other *** search
/ Kompuutteri Kaikille K-CD 2002 #1 / K-CD_2002-01.iso / Delphi / INSTALL / program files / Borland / Delphi6 / Source / Samples / Calendar.pas next >
Pascal/Delphi Source File  |  2001-05-22  |  9KB  |  306 lines
  1. unit Calendar;
  2.  
  3. interface
  4.  
  5. uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
  6.   Grids, SysUtils;
  7.  
  8. type
  9.   TDayOfWeek = 0..6;
  10.  
  11.   TCalendar = class(TCustomGrid)
  12.   private
  13.     FDate: TDateTime;
  14.     FMonthOffset: Integer;
  15.     FOnChange: TNotifyEvent;
  16.     FReadOnly: Boolean;
  17.     FStartOfWeek: TDayOfWeek;
  18.     FUpdating: Boolean;
  19.     FUseCurrentDate: Boolean;
  20.     function GetCellText(ACol, ARow: Integer): string;
  21.     function GetDateElement(Index: Integer): Integer;
  22.     procedure SetCalendarDate(Value: TDateTime);
  23.     procedure SetDateElement(Index: Integer; Value: Integer);
  24.     procedure SetStartOfWeek(Value: TDayOfWeek);
  25.     procedure SetUseCurrentDate(Value: Boolean);
  26.     function StoreCalendarDate: Boolean;
  27.   protected
  28.     procedure Change; dynamic;
  29.     procedure ChangeMonth(Delta: Integer);
  30.     procedure Click; override;
  31.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  32.     function DaysThisMonth: Integer; virtual;
  33.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  34.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  35.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  36.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  37.   public
  38.     constructor Create(AOwner: TComponent); override;
  39.     property CalendarDate: TDateTime  read FDate write SetCalendarDate stored StoreCalendarDate;
  40.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  41.     procedure NextMonth;
  42.     procedure NextYear;
  43.     procedure PrevMonth;
  44.     procedure PrevYear;
  45.     procedure UpdateCalendar; virtual;
  46.   published
  47.     property Align;
  48.     property Anchors;
  49.     property BorderStyle;
  50.     property Color;
  51.     property Constraints;
  52.     property Ctl3D;
  53.     property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
  54.     property DragCursor;
  55.     property DragKind;
  56.     property DragMode;
  57.     property Enabled;
  58.     property Font;
  59.     property GridLineWidth;
  60.     property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
  61.     property ParentColor;
  62.     property ParentFont;
  63.     property ParentShowHint;
  64.     property PopupMenu;
  65.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  66.     property ShowHint;
  67.     property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
  68.     property TabOrder;
  69.     property TabStop;
  70.     property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
  71.     property Visible;
  72.     property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
  73.     property OnClick;
  74.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  75.     property OnDblClick;
  76.     property OnDragDrop;
  77.     property OnDragOver;
  78.     property OnEndDock;
  79.     property OnEndDrag;
  80.     property OnEnter;
  81.     property OnExit;
  82.     property OnKeyDown;
  83.     property OnKeyPress;
  84.     property OnKeyUp;
  85.     property OnStartDock;
  86.     property OnStartDrag;
  87.   end;
  88.  
  89. implementation
  90.  
  91. constructor TCalendar.Create(AOwner: TComponent);
  92. begin
  93.   inherited Create(AOwner);
  94.   { defaults }
  95.   FUseCurrentDate := True;
  96.   FixedCols := 0;
  97.   FixedRows := 1;
  98.   ColCount := 7;
  99.   RowCount := 7;
  100.   ScrollBars := ssNone;
  101.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  102.   FDate := Date;
  103.   UpdateCalendar;
  104. end;
  105.  
  106. procedure TCalendar.Change;
  107. begin
  108.   if Assigned(FOnChange) then FOnChange(Self);
  109. end;
  110.  
  111. procedure TCalendar.Click;
  112. var
  113.   TheCellText: string;
  114. begin
  115.   inherited Click;
  116.   TheCellText := CellText[Col, Row];
  117.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  118. end;
  119.  
  120. function TCalendar.IsLeapYear(AYear: Integer): Boolean;
  121. begin
  122.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  123. end;
  124.  
  125. function TCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  126. const
  127.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  128. begin
  129.   Result := DaysInMonth[AMonth];
  130.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  131. end;
  132.  
  133. function TCalendar.DaysThisMonth: Integer;
  134. begin
  135.   Result := DaysPerMonth(Year, Month);
  136. end;
  137.  
  138. procedure TCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  139. var
  140.   TheText: string;
  141. begin
  142.   TheText := CellText[ACol, ARow];
  143.   with ARect, Canvas do
  144.     TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
  145.       Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  146. end;
  147.  
  148. function TCalendar.GetCellText(ACol, ARow: Integer): string;
  149. var
  150.   DayNum: Integer;
  151. begin
  152.   if ARow = 0 then  { day names at tops of columns }
  153.     Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  154.   else
  155.   begin
  156.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  157.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  158.     else Result := IntToStr(DayNum);
  159.   end;
  160. end;
  161.  
  162. function TCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  163. begin
  164.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  165.     Result := False
  166.   else Result := inherited SelectCell(ACol, ARow);
  167. end;
  168.  
  169. procedure TCalendar.SetCalendarDate(Value: TDateTime);
  170. begin
  171.   FDate := Value;
  172.   UpdateCalendar;
  173.   Change;
  174. end;
  175.  
  176. function TCalendar.StoreCalendarDate: Boolean;
  177. begin
  178.   Result := not FUseCurrentDate;
  179. end;
  180.  
  181. function TCalendar.GetDateElement(Index: Integer): Integer;
  182. var
  183.   AYear, AMonth, ADay: Word;
  184. begin
  185.   DecodeDate(FDate, AYear, AMonth, ADay);
  186.   case Index of
  187.     1: Result := AYear;
  188.     2: Result := AMonth;
  189.     3: Result := ADay;
  190.     else Result := -1;
  191.   end;
  192. end;
  193.  
  194. procedure TCalendar.SetDateElement(Index: Integer; Value: Integer);
  195. var
  196.   AYear, AMonth, ADay: Word;
  197. begin
  198.   if Value > 0 then
  199.   begin
  200.     DecodeDate(FDate, AYear, AMonth, ADay);
  201.     case Index of
  202.       1: if AYear <> Value then AYear := Value else Exit;
  203.       2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
  204.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
  205.       else Exit;
  206.     end;
  207.     FDate := EncodeDate(AYear, AMonth, ADay);
  208.     FUseCurrentDate := False;
  209.     UpdateCalendar;
  210.     Change;
  211.   end;
  212. end;
  213.  
  214. procedure TCalendar.SetStartOfWeek(Value: TDayOfWeek);
  215. begin
  216.   if Value <> FStartOfWeek then
  217.   begin
  218.     FStartOfWeek := Value;
  219.     UpdateCalendar;
  220.   end;
  221. end;
  222.  
  223. procedure TCalendar.SetUseCurrentDate(Value: Boolean);
  224. begin
  225.   if Value <> FUseCurrentDate then
  226.   begin
  227.     FUseCurrentDate := Value;
  228.     if Value then
  229.     begin
  230.       FDate := Date; { use the current date, then }
  231.       UpdateCalendar;
  232.     end;
  233.   end;
  234. end;
  235.  
  236. { Given a value of 1 or -1, moves to Next or Prev month accordingly }
  237. procedure TCalendar.ChangeMonth(Delta: Integer);
  238. var
  239.   AYear, AMonth, ADay: Word;
  240.   NewDate: TDateTime;
  241.   CurDay: Integer;
  242. begin
  243.   DecodeDate(FDate, AYear, AMonth, ADay);
  244.   CurDay := ADay;
  245.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  246.   else ADay := 1;
  247.   NewDate := EncodeDate(AYear, AMonth, ADay);
  248.   NewDate := NewDate + Delta;
  249.   DecodeDate(NewDate, AYear, AMonth, ADay);
  250.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  251.   else ADay := DaysPerMonth(AYear, AMonth);
  252.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  253. end;
  254.  
  255. procedure TCalendar.PrevMonth;
  256. begin
  257.   ChangeMonth(-1);
  258. end;
  259.  
  260. procedure TCalendar.NextMonth;
  261. begin
  262.   ChangeMonth(1);
  263. end;
  264.  
  265. procedure TCalendar.NextYear;
  266. begin
  267.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  268.   Year := Year + 1;
  269. end;
  270.  
  271. procedure TCalendar.PrevYear;
  272. begin
  273.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  274.   Year := Year - 1;
  275. end;
  276.  
  277. procedure TCalendar.UpdateCalendar;
  278. var
  279.   AYear, AMonth, ADay: Word;
  280.   FirstDate: TDateTime;
  281. begin
  282.   FUpdating := True;
  283.   try
  284.     DecodeDate(FDate, AYear, AMonth, ADay);
  285.     FirstDate := EncodeDate(AYear, AMonth, 1);
  286.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
  287.     if FMonthOffset = 2 then FMonthOffset := -5;
  288.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  289.       False, False);
  290.     Invalidate;
  291.   finally
  292.     FUpdating := False;
  293.   end;
  294. end;
  295.  
  296. procedure TCalendar.WMSize(var Message: TWMSize);
  297. var
  298.   GridLines: Integer;
  299. begin
  300.   GridLines := 6 * GridLineWidth;
  301.   DefaultColWidth := (Message.Width - GridLines) div 7;
  302.   DefaultRowHeight := (Message.Height - GridLines) div 7;
  303. end;
  304.  
  305. end.
  306.